perm filename FUEXP.F4[2,LCS] blob
sn#155831 filedate 1975-04-18 generic text, type T, neo UTF8
C THIS PROGRAM(FUCOL.F4) CREATES FUNCTIONS FOR THE MUSIC PROGRAM
C USING 'SEG' OR 'SYNTH'. UP TO 10 FUNCTIONS CAN BE STORED IN A
C SINGLE FILE. ONCE CREATED, THE FUNCTIONS MAY BE CHANGED
C AND PUT BACK IN THE SAME FILE OR INTO A NEW ONE.
C NO MORE THAN 50 INPUTS FOR ONE FUNCTION!
C TYPE 'C'(= CRUNCH) FOR SPECIAL FEATURE SUBR TO COMBINE FUNCS
C ALREADY MADE. [MULT, ADD, RETRO, INVRT, ADD CONSTANT ]
C SEG FUNCS MAY BE 'SMOOTHED' BUT THIS FEATURE AND 'CRUNCH' SHOULD
C BE USED SPARINGLY AS ALL 512 WDS OF THE ARRAY MUST BE SAVED. THIS
C CLUTTERS UP THE DSK.
C 'Z' FOR "CHANGE OR FINISH?" WILL JUMP DIRECTLY TO "CRUNCH" MODE.
C BUT ONCE CHANGED BY 'CRUNCH' THIS UNSTORED ORIG. IS LOST.
C'SP'(FOR "SEE")PLOTS ONE FUNC. (SA=PLOT ALL); 'SL' PUTS IT OUT ON
C THE LPT.
C FOR EXPONENTIALS GET INTO 'SEG'. TYPE 'X', DECAY FAC, N. IF
C N IS NON-ZERO THE FUNCTION WILL NOT! NORMALIZE (IE. NOT GO TO 0).
C AFTER A FILE HAS BEEN READ IN,
C THE DECAY FAC. IS THE NUM ALONGTHE SCALE(1-100) WHERE THE CURVE
C SEEMS TO TOUCH ZERO. (WILL ALWAYS HIT 0 AT END UNLESS N.NE.0.)
C <CR> FOR 'TYPE FILE' WILL HOLD ON TO IT.
C LOAD WITH -- WRIFUN,FUSUB,DFUEXP,SSS,LOOK.FAI (+RANFIL.MAC?)
COMMON/S/H,AMP,CON,PH
COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
COMMON FUNC(512),F2(512),K,I
COMMON/LT/LPTY,JSEE
DIMENSION RF(4)
21 FORMAT(' C=CHANGE, F=FINISH '$)
22 FORMAT(' NEW FUNC, EDIT, CRUNCH, DELETE, RENAME, SEE? '$)
23 FORMAT(' SEG OR SYNTH? '$)
25 FORMAT(' TYPE FILE NAME '$)
26 FORMAT(I3,') TYPE AMPL, STEP# '$)
C 'X' HERE WILL MAKE EXPON. FUNC.
28 FORMAT(' 0=NORM,OR H,A,P,K '$)
280 FORMAT(
1' UP TO 10 FUNCTIONS MAY BE STORED IN EACH FILE'/
1' TYPE "B" TO BACKUP AT ANY TIME'//)
30 FORMAT(8F)
31 FORMAT(1XA5,A1,5A5/)
35 FORMAT(1XA5,'IN FILE "',A5,'.DAT"'/)
37 FORMAT(8F9.3)
371 FORMAT(I3,') ',4F8.2)
372 FORMAT(I,21F)
38 FORMAT(2(A5,A1),23A2)
40 FORMAT(11(A1,A3))
41 FORMAT(' ADD TO AN EXISTING FILE? '$)
42 FORMAT(' WHICH FUNC? '$)
47 FORMAT(' C=CHNG, I=INSRT, D=DEL -- + LN# & CHNGS '$)
48 FORMAT(' X,N(=DECAY FAC.) FOR XPONTLS')
2281 TYPE 280
281 KZ=0
JSEE=0
LPTY=5
C USED IN RELATIVE VECTOR ROUTINE
Z=0
EY=0
ICUR=0
XP=0
KT=0
FNUM=0
OLD=0
FNUM1=0
TYPE 22
ACCEPT 40,ON,P
PLTALL=0
IF(P.EQ.'A'.OR.P.EQ.'X')PLTALL=-1
1281 IPLOT=0
CC 7/74 COLGATE IF(ON.EQ.'N'.OR.(ON.EQ.' '.AND.ONX.NE.'S'))GO TO 1000
IF(ON.EQ.'N')GO TO 1000
IF(ON.EQ.'E'.OR.ON.EQ.'R'.OR.ON.EQ.'D'
1 .OR.ON.EQ.'C'.OR.ON.EQ.'S')GO TO 100
CC 7/74 COLGATE ON=ONX
C ---OUT 7/74--- RETURNS FOR MORE "SEE"
CC 7/74 COLGATE GO TO 4281
GO TO 281
C WON'T GO ON IF BLANK
100 ONX=ON
TYPE 25
OLD=-1
ACCEPT 38,FLNM1
IF(FLNM1.EQ.' ')FLNM1=FLNM
IF(FLNM1.EQ.0.OR.LOOKD(FLNM1).EQ.0)GO TO 100
CC NOT YET! IF(FLNM1.EQ.0.OR.LOOKU(FLNM1).EQ.0)GO TO 100
C LOOKS UP NAME.DAT
IF(FLNM.NE.FLNM1)GO TO 2151
OLD=0
4281 TYPE 40,B
IF(PLTALL)GO TO 5402
GO TO 1402
2151 FLNM=FLNM1
CALL READ1
3402 LX=0
TYPE 40,B
IF(PLTALL)GO TO 402
C "SA" WILL PLOT ALL FUNCS IN FILE
JX=-1
IF(B(1,2).NE.' ')GO TO 1402
FNUM1=B(2,1)
C ONLY ONE FUNC IN FILE.
GO TO 402
1402 TYPE 42
ACCEPT 40,BU
IF(BU.EQ.' ')GO TO 1402
IF(BU.NE.'B')GO TO 380
FLNM=0
JX=0
GO TO 281
380 REREAD 38,FNUM1
IDEL=0
C LX IS MAIN COUNTER
IF(OLD)GO TO 402
DO 1302 JX=1,10
1302 IF(FNUM1.EQ.FN(JX))GO TO 5402
CC 7/74 WHY WAS THIS HERE???? GO TO 3402
GO TO 100
2202 CALL DPYF(-1,FUNC)
C -1 SUPRESSES DISPLAY
IF(P.EQ.'P'.OR.P.EQ.'A'.OR.P.EQ.0)GO TO 70
LPTY=3
JSEE=-1
CALL DPY(FUNC,1)
CALL EXIT
70 CALL PLOTIT(FUNC,XA(JX),P)
IF(P.EQ.'P')GO TO 2281
JX=JX+1
IF(B(2,JX).NE.' '.AND.JX.LE.10)GO TO 2202
CC*** GO TO 2281
CALL EXIT
402 CALL READER
IF(JX)GO TO 100
C 6/74 GO BACK IF IT DIDN'T FIND THE FUNC NAME IN THIS FILE.
C AT THIS POINT LX=TOTAL FUNCS+1
5402 IF(PLTALL)JX=1
1202 IF(ON.NE.'C'.AND.ON.NE.'S'.AND.ON.NE.'D')GO TO 3281
IF(P.EQ.'P'.OR.P.EQ.'L'.OR.P.EQ.'A')GO TO 2202
CALL DPYF(JX,FUNC)
IF(PLTALL.OR.P.EQ.'P'.OR.P.EQ.0)GO TO 2202
IF(ON.EQ.'S')GO TO 2281
IF(ON.EQ.'C')GO TO 1201
1140 TYPE 1139
ACCEPT 40,IDEL
IF(IDEL.EQ.'N')GO TO 2281
IF(IDEL.NE.'Y')GO TO 1140
IDEL=JX
LX=LX-1
C NOW LX=TOTAL # OF FUNCS.
CALL WRIFUN
1139 FORMAT(' DELETE IT? ',$)
CC2202 CALL PLOTIT(FUNC,XA(JX),P)
CC IF(P.EQ.'P')GO TO 2281
CC JX=JX+1
CC IF(B(2,JX).NE.' '.AND.JX.LE.10)GO TO 1202
CCC "SA" KEEPS PLOTTING UNTIL NO MORE ARE FOUND
CC GO TO 2281
3281 X=' '
TYPE 31,XA(JX),X,FN(JX)
JT=4
IF(XA(JX).EQ.'SEG')JT=2
KZ=1
DO 137 K=1,50
KZ=KZ+1
DO 138 L=1,JT
138 A(K,L)=AA(L,K,JX)
137 IF(A(K,1).EQ.999.OR.A(K,2).GE.100)GO TO 4401
4401 Z=-1
IF(A(K,2).LE.100)GO TO 4403
IF(K.GT.1)GO TO 4404
CALL DPYF(JX,FUNC)
IF(ON.EQ.'R')GO TO 3032
TYPE 4405
A(1,2)=520
GO TO 4201
4404 TYPE 4402
4403 IF(JT.EQ.2)EY='EG'
GO TO 1032
4402 FORMAT(' IT WAS SMOOTHED.')
4405 FORMAT(' CANNOT EDIT CRUNCHED FUNCS.'/)
1000 TYPE 23
ACCEPT 40,BU
IF(BU.EQ.'B')GO TO 281
REREAD 40,X,EY
1032 CALL ZERO(FUNC)
C CLEARS THE FUNC.
ISMOO=0
IF(EY.EQ.'EG')GO TO 800
151 EY=0
JT=4
C FOR WRIFUN
15 KT=1
104 IF(Z.EQ.-1.OR.KT.LT.KZ)GO TO 102
IF(Z.EQ.1)GO TO 2032
1041 KZ=0
TYPE 28
Z=0
C:::: 6/74 COLGATE Z=0
ACCEPT 40,BU
IF(BU.EQ.'B')GO TO 509
REREAD 30,(A(KT,K),K=1,4)
C ACCEPT HARM,AMPL,PHASE,KONSTANT(IF K>100, MULTIPLIES WAVE *(K-100))
102 H=A(KT,1)
IF(H.EQ.0.OR.H.EQ.999.)GO TO 2200
C 999 ENDS 'READIN' SYNTHS
IF(Z.GT.0)TYPE 371,KT,(A(KT,K),K=1,4)
AMP=A(KT,2)
PH=A(KT,3)
CON=A(KT,4)
CALL SYN(FUNC)
KT=KT+1
IF(KZ.LE.KT)CALL DPY(FUNC,1)
GO TO 104
2201 IF(JT.NE.2.OR.A(KT-1,2).GT.100)GO TO 1201
C TO USE CURRENT FUNC IN CRUNCH
IF(LX.GT.10)GO TO 204
CALL STORE(10)
C PUTS FROM A ARRAY TO AA ARRAY
XA(K)='SEG'
CC 6/74 COLGATE--SEE ALSO FUSUB CALL DPYF(K,FUNC)
CALL DPYF(10,FUNC)
1201 CALL ZFUNC
C THIS WILL BE FOR SPECIAL FEATURE PACKAGE
IF(KT.EQ.512)GO TO 2281
C FOR BACKUP
4201 EY='EG'
KT=2
GO TO 900
2200 IF(KT.LE.1)GO TO 509
C 7/74 COLGATE BACKUP IF NO INPUT TO SYNTH
CC2200 CALL NORM(FUNC)
CALL NORM(FUNC)
C NORMALIZES THE FUNCTION
201 CALL DPY(FUNC,1)
IF(BU.EQ.'C')GO TO 2032
IF(ON.EQ.'R')GO TO 3032
204 TYPE 21
IF(EY.EQ.'EG')TYPE 271
C CHANGE IT?
ACCEPT 40,BU
IF(BU.EQ.'C')GO TO 210
IF(BU.EQ.'F')GO TO 900
IF(BU.EQ.'S')GO TO 7000
IF(BU.EQ.'Z')GO TO 2201
C TO USE CURRENT FUNC IN CRUNCH
IF(BU.NE.'B')GO TO 2032
IF(EY.EQ.'EG')GO TO 509
GO TO 5091
C NEXT IS FOR CHANGES ('C' OR <CR>)
2032 TYPE 47
ACCEPT 40,K
REREAD 372,L,X,RF
IF(X.NE.0.OR.RF(1).NE.0)GO TO 211
IF(EY.EQ.'EG')GO TO 204
BU=0
GO TO 1041
211 L=X
IF(K.EQ.'I')GO TO 212
IF(K.NE.'D')GO TO 205
C JUMP IF NO DELETE
KT=KT-1
DO 209 K=L,KT
DO 209 J=1,4
209 A(K,J)=A(K+1,J)
GO TO 210
205 X=RF(2)
IF(EY.NE.'EG')GO TO 1207
IF(X.GE.A(L+1,2).AND.L.LT.KT-1)GO TO 2032
GO TO 208
212 IF(RF(2).NE.0)GO TO 213
RF(2)=RF(1)
RF(1)=X
L=KT
213 IF(EY.NE.'EG')GO TO 214
X=RF(2)
DO 215 K=1,KT
Y=A(K,2)
IF(X.GT.Y)GO TO 215
C JUMP IF NOT PAST STEP NUM.
L=K
IF(X.EQ.Y)GO TO 208
C IF STEP=ANOTHER STEP, IT WORKS LIKE 'C'HANGE.
GO TO 214
215 CONTINUE
214 KT=KT+1
DO 206 K=KT,L,-1
DO 206 J=1,4
206 A(K,J)=A(K-1,J)
GO TO 207
C TO TYPE OLD NUMBERS
208 IF(X.LE.A(L-1,2).AND.L.GT.1)GO TO 2032
1207 TYPE 371,L,(A(L,K),K=1,4)
207 DO 202 K=1,4
202 A(L,K)=RF(K)
210 KZ=KT
Z=1
GO TO 1032
271 FORMAT('+S=SMOOTH '$)
C FOR RENAMES
3032 Z=-1
GO TO 901
900 TYPE 41
C ADD TO EXISTING FILE
ISKP=0
ACCEPT 40,Z
9000 IF(Z.EQ.'B')GO TO 204
IF(Z.NE.'Y'.AND.Z.NE.'N')GO TO 900
TYPE 25
ACCEPT 38,FLNM
IF(FLNM.EQ.' '.AND.FLNM1.NE.' ')FLNM=FLNM1
IF(FLNM.EQ.'B'.OR.FLNM.EQ.' ')GO TO 204
CC*** NOT YET! IF(LOOKU(FLNM))GO TO 902
C LOOKS UP NAME.DAT (NOT .FUN AS YET)
IF(LOOKD(FLNM))GO TO 902
IF(Z.NE.'N')GO TO 900
C LOOKD CHECKS ON LOOK-UP
901 JT=4
IF(EY.EQ.'EG')JT=2
IDEL=0
CALL WRIFUN
GO TO 900
C COMES BACK IF NO ROOM IN FILE FOR NEW FUNC.
902 IF(Z.NE.'N')GO TO 901
TYPE 381,FLNM
ACCEPT 40,Z
IF(Z.EQ.'Y')GO TO 903
GO TO 9000
903 Z='N'
GO TO 901
C 7/74 COLGATE NOW WILL REALLY WRITE OVER A FILE!
381 FORMAT(/9X'WRITE OVER ',A5,'.DAT? ',$)
161 DO 261 K=1,512
261 FUNC(K)=EXP((1-K)/STEP)
KT=2
XP=-1
IF(H.NE.0)GO TO 7009
C H≠0 = NO NORMALIZATION OF XPONTL
X=FUNC(512)
DO 361 K=1,512
361 FUNC(K)=FUNC(K)-(K-1)/511.*X
GO TO 7009
800 IF(XP)GO TO 510
X=0
IK=0
JT=2
C JT AND EY SEEM TO PERFORM THE SAME FUNCTIONS??
Y=0
KT=1
504 IF(KT.GE.KZ)GO TO 510
AMP=A(KT,1)
5008 STEP=A(KT,2)
IF(STEP.LE.A(KT-1,2).AND.KT.GT.1)GO TO 509
C SO IT CAN'T GO BACKWARDS
GO TO 5071
611 FORMAT(' NO MORE THAN 50 SEGS'/)
610 TYPE 611
509 KT=KT-1
5091 IF(KT.LT.1)GO TO 281
GO TO 210
510 IF(KT.EQ.1)TYPE 48
TYPE 26,KT
KZ=0
ACCEPT 40,BU
IF(BU.EQ.'B')GO TO 509
61 REREAD 30,AMP,STEP,H
IF(STEP.LT.1)STEP=1
IF(BU.EQ.'X')GO TO 161
C TYPE 'X' FOR EXPON. FUNC. + DECAY FACTOR, +1 = NO NORM.
C WE START WITH STEP 1 (NOT 0)
5071 IF(KT.GT.50)GO TO 610
C TOO MANY SEGS
IF(Z.GT.0)TYPE 371,KT,AMP,STEP
IF(STEP.GT.100)STEP=100
STPS=STEP-X
IF(STPS.LE.0.AND.KT.NE.1)GO TO 504
C SO IT CAN'T BACKUP HERE
IS=STPS
IF(STEP.LE.1.)Y=AMP
CC COLGATE 6/74 DIF=(AMP-Y)/STPS
IF(IS.NE.0)DIF=(AMP-Y)/STPS
IJ=STPS*5.12
203 DO 2031 K=1,IJ
2031 FUNC(K+IK)=Y+DIF*K/5.12
C 100 STEPS ARE CONVERTED HERE TO 512
IK=IK+IJ
12 Y=AMP
X=STEP
A(KT,1)=Y
A(KT,2)=X
7001 KT=KT+1
C KT COUNTS SEGMENTS
IF(STEP.LT.100)GO TO 504
GO TO 201
7000 IF(ISMOO)GO TO 201
IF(KT.LE.20)GO TO 7007
TYPE 7008
GO TO 509
7008 FORMAT(' NO MORE THAN 20 SEGS IN CURVES'/)
7007 CALL SSS(A,KT-1,FUNC)
C DRAWS GRID 2
7009 A(KT-1,2)=520
ISMOO=-1
C SO YOU CAN'T COME BACK 2 TIMES
GO TO 201
END
SUBROUTINE WRIFUN
COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
1,LX,JX,J,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
COMMON FUNC(512),F2(512),K,I
DATA ARY/'ARRAY'/,R999/999.0/
24 FORMAT(' TYPE FUNCTION NAME '$)
34 FORMAT(A5,'(',A5,');',A5)
35 FORMAT(1XA5,'IN FILE "',A5,'.DAT"'/)
37 FORMAT(8F10.4)
39 FORMAT(A5,10(A1,A3))
391 FORMAT(A3)
390 FORMAT(A1)
43 FORMAT(' NO ROOM IN FILE "',A5,'.DAT"')
44 FORMAT(' FUNCTIONS ALREADY IN FILE - ',A5)
45 FORMAT('(512);')
MX=0
IF(IDEL.NE.0)GO TO 292
C FOR DELETIONS
IF(Z.EQ.'N')GO TO 912
IF(FLNM.EQ.FLNM1)GO TO 1922
C JUMP IF THAT FILE IS NOW IN CORE
CC REWIND 1
CC CALL IFILE(1,FLNM)
CC READ(1,39),X,B
CALL READ1
1922 IF(Z.EQ.'N')GO TO 912
CC COLGATE 7/741922 TYPE 44,FLNM
TYPE 44,FLNM
C FUNCS. IN FILE
TYPE 39,MX,B
912 TYPE 24
ACCEPT 390,FNUM
IF(FNUM.EQ.'B')RETURN
C FOR BACKUP
IF(FNUM.EQ.' ')GO TO 1922
REREAD 391,FNUM
IF(Z.EQ.'N')GO TO 911
IF(Z.NE.-1)GO TO 90
C JUMP IF .NE. 'RENAME'
C 7/74 COLGATE
DO 30 K=1,LX-1
IF(K.EQ.JX.OR.FN(K).NE.FNUM)GO TO 30
TYPE 31
CALL EXIT
31 FORMAT(/' FUNC NAME IN USE!')
30 CONTINUE
B(2,JX)=FNUM
FN(JX)=FNUM
LX=LX-1
CC MX=127
GO TO 1906
90 IF(FLNM.EQ.FLNM1)GO TO 1090
FNUM1=0
LX=0
C TO PUT NEW FUNC IN OLD FILE
CALL READER
1090 JX=0
MX=LX
DO 20 K=1,LX-1
IF(FNUM.NE.FN(K))GO TO 20
JX=K
LX=LX-1
GO TO 21
20 CONTINUE
210 JX=LX
C JX=LX IF FNUM WAS NOT FOUND
IF(JX.GT.10)GO TO 193
21 FN(JX)=FNUM
X='SEG'
IF(J.EQ.4)X='SYNTH'
XA(JX)=X
CALL STORE(JX)
IF(J.EQ.2)GO TO 1192
AA(1,KT,JX)=999
GO TO 192
1192 IF(A(KT-1,2).EQ.100)GO TO 192
C JUMP IF NO SMOOTHING
DO 2192 K=1,512
2192 AA(K,KT,JX)=FUNC(K)
192 IF(JX.NE.1)B(1,JX)=','
B(2,JX)=FNUM
GO TO 1906
193 TYPE 43,FLNM
C NO ROOM IN FILE.
RETURN
C NEW FILE
911 LX=1
DO 94 K=1,20
94 B(K,1)=' '
GO TO 210
C CLEARS B FOR NEW, SINGLE ITEM.
292 IF(IDEL.EQ.10)GO TO 932
DO 931 K=IDEL,LX-1
CC FN(K)=FN(K+1)
931 B(2,K)=B(2,K+1)
932 B(1,LX)=' '
B(2,LX)=' '
1906 REWIND 1
IF(Z.EQ.'N'.OR.IDEL.GT.0)GO TO 22
DO 25 K=1,LX
IF(K.GT.1.AND.B(1,K).NE.',')GO TO 26
X=B(2,K)
IF(X.NE.' '.AND.X.EQ.FN(K))GO TO 25
26 TYPE 23
RETURN
23 FORMAT(/' CONFUSION IN THIS FILE. TRY ANOTHER! '/)
25 CONTINUE
22 CALL OFILE(1,FLNM)
CC NOT YET! 22 CALL OFLE(1,FLNM,'.FUN')
C COLGATE OFILE REPLACEMENT. ALL FUNC FILES WILL BE '.FUN'.
WRITE(1,39),ARY,B
WRITE(1,45)
69 NX=0
1905 IF(NX.EQ.LX)GO TO 904
C LX=TOTAL # OF FUNCS
NX=NX+1
IF(IDEL.EQ.NX)GO TO 1905
C SO THAT DATA MUST ALWAYS BE READ FROM DSK AFTER A DEL.
CC1 YA(NX)=' '
CC IF(XA(NX).EQ.'SYNTH')YA(NX)=' 99'
CC WRITE(1,34),XA(NX),FN(NX),YA(NX)
1 J=4
X=' 99'
IF(XA(NX).NE.'SEG')GO TO 68
J=2
X=' '
68 WRITE(1,34),XA(NX),FN(NX),X
JX=0
2905 JX=JX+1
IF(J.EQ.2)GO TO 3905
IF(AA(1,JX,NX).EQ.999)GO TO 5905
C FOUND END OF A SYNTH
WRITE(1,37),(AA(K,JX,NX),K=1,4)
GO TO 2905
5905 WRITE(1,37)R999
GO TO 1905
3905 X=AA(2,JX,NX)
WRITE(1,37),AA(1,JX,NX),X
IF(X.EQ.100)GO TO 1905
C FOUND END OF A SEG
IF(X.LT.100)GO TO 2905
WRITE(1,37)(AA(K,JX+1,NX),K=1,512)
GO TO 1905
904 TYPE 39,MX,B
IF(IDEL.EQ.0)TYPE 35,FNUM,FLNM
IF(IDEL.NE.0)FLNM=0
LX=LX+1
C FOR RESTARTS
CALL EXIT
END
SUBROUTINE READER
COMMON/LN/LINE
COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
1,LX,JX,J,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
COMMON FUNC(512),F2(512),K,I
37 FORMAT(8F)
38 FORMAT(3(A5,A1))
380 FORMAT(I,3(A5,A1))
39 FORMAT(9A5)
READ (1,39),K,K,AK
C READS "(512);"
C LX IS MAIN COUNTER
401 LX=LX+1
1 IF(LINE.EQ.0)READ(1,38,END=4401)XA(LX),Y,FN(LX),H,H
IF(LINE)READ(1,380,END=4401)K,XA(LX),Y,FN(LX),H,H
IF(XA(LX).GE.0)GO TO 1
C TO FIND EOF AFTER COPY SCREWUPS
IF(FNUM1.EQ.FN(LX))JX=LX
C JX TELLS WHERE TO FIND FUNCTION TO BE LOOKED AT.
C XA(LX) IS FUNC. TYPE (SEG OR SYNTH)
X=0
N=4
IF(XA(LX).EQ.'SEG')N=2
KX=0
C KX IS LOCAL COUNTER
1401 IF(X.EQ.100)GO TO 401
KX=KX+1
IF(LINE.EQ.0)READ(1,37),(AA(K,KX,LX),K=1,N)
IF(LINE)READ(1,37)AK,(AA(K,KX,LX),K=1,N)
IF(N.EQ.2)GO TO 2401
IF(AA(1,KX,LX).EQ.999)GO TO 401
C FOUND END OF A SYNTH
GO TO 1401
2401 X=AA(2,KX,LX)
IF(X.LE.100)GO TO 1401
C NEXT IS FOR SMOOTHED SEGS
N=KX+1
IF(LINE)GO TO 2
READ(1,37)(AA(K,N,LX),K=1,512)
GO TO 401
370 FORMAT(9F)
2 DO 3 K=1,512,8
3 READ(1,370)AK,(AA(KX,N,LX),KX=K,K+7)
GO TO 401
4401 RETURN
END
SUBROUTINE READ1
C READS FIRST LINE OF FILE ONLY
COMMON/LN/LINE
COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
2151 REWIND 1
CALL IFILE(1,FLNM)
CC NOT YET! CALL IFLE(1,FLNM,'.FUN')
READ (1,39),X,B
LINE=0
IF(X)RETURN
LINE=-1
C FOUND LN #S (CAN'T READ SMOOTHS 'THO)
REREAD 390,LX,X,B
RETURN
39 FORMAT(A5,10(A1,A3))
390 FORMAT(I,A5,10(A1,A3))
END
SUBROUTINE STORE(N)
COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
1,LX,JX,J,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
DO 3090 K=1,KT-1
DO 3090 L=1,J
3090 AA(L,K,N)=A(K,L)
RETURN
END
C ********** DISPLAY OR PLOT OUTPUT **********
SUBROUTINE DPY(F,IY)
DIMENSION H(120)
COMMON/LT/LPTY,JSEE
DIMENSION F(1)
DATA Q/'X'/
IF(JSEE)GO TO 1
TYPE 2
ACCEPT 3,N
IF(N.NE.'Y')RETURN
1 M=72
JR=12
NN=23
IF(LPTY.EQ.5)GO TO 7
M=120
JR=26
NN=51
7 RH=512.0/M
T=1
S=2.0/NN+.001
DO 4 K=1,NN
R=1.-K*S
H(1)='!'
A=' '
IF(K.EQ.JR)A='-'
6 DO 11 L=2,M
11 H(L)=A
J=1
RJ=1
12 DO 9 L=1,M
A=F(J)
IF(A.GT.R.AND.A.LE.T)H(L)=Q
RJ=RJ+RH
9 J=RJ
T=R
4 WRITE(LPTY,20)(H(L),L=1,M)
IF(LPTY.NE.5)RETURN
TYPE 5
ACCEPT 3,N
RETURN
20 FORMAT(1X120A1)
2 FORMAT(' SEE IT? '$)
3 FORMAT(A1)
5 FORMAT(' <CR>=CONTINUE'$)
END
SUBROUTINE PLOTIT(FUNC,EY,P)
COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
DIMENSION FUNC(1)
IF(P.EQ.'P')GO TO 1
IF(P.EQ.0)GO TO 4
Y=1
X=2.
CC IF(P.NE.'X')GO TO 6
CC X=1.5
CC Y=.5
6 CALL PLOTS(K)
P=0
GO TO 40
1 TYPE 2
CALL PLOTS(K)
ACCEPT 3,X
IF(X.EQ.0)X=SZX
IF(X.EQ.0)X=1.
SZX=X
40 SZ=X/5.12
CALL PLOT(0,17.*SZ,-3)
C ABOVE FOR COLGATE PLOTTER.
41 S=0
J=1
RJK=X/8.
CALL SYMBOL(SZ,4.*SZ,RJK,FLNM,0,5)
4 CALL SYMBOL(SZ,-3.*SZ,RJK,B(2,JX),0,3)
CALL PLOT(5.12*SZ,0.,3)
CALL PLOT(0.,0.,2)
CALL PLOT(0.,-2.*SZ,3)
CALL PLOT(0.,2.*SZ,2)
72 CALL PLOT(.01*SZ,FUNC(1)*2.*SZ,3)
DO 73 K=2,512
R=K/100.0
73 CALL PLOT(R*SZ,FUNC(K)*2.*SZ,2)
T=0
Q=Y+5*SZ
IF(J.NE.5)GO TO 5
Q=-S
T=-7*SZ
5 CALL PLOT(Q,T,-3)
S=S+Q
J=J+1
RETURN
2 FORMAT(' TYPE SIZE - '$)
3 FORMAT(F)
END
SUBROUTINE ZFUNC
COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
COMMON FUNC(512),F2(512),K,I
43 TYPE 1
ACCEPT 100,MA,C
IF(MA.NE.'B')GO TO 76
430 KT=512
C FOR BACKUP
RETURN
76 IF(MA.NE.'A'.AND.MA.NE.'M')GO TO 73
75 TYPE 39,B
TYPE 2
ACCEPT 3,FNM2
IF(FNM2.EQ.'B')GO TO 43
40 DO 4 K=1,10
5 IF(FNM2.NE.FN(K))GO TO 4
N2=K
GO TO 72
4 CONTINUE
TYPE 74
GO TO 75
74 FORMAT(' FUNCTION NOT FOUND '/)
72 CALL DPYF(N2,F2)
7 TYPE 60
ACCEPT 100,K
IF(K.EQ.'B'.OR.K.EQ.'N')GO TO 15
IF(MA.EQ.'M')GO TO 102
70 TYPE 10
ACCEPT 11,R,R2
REREAD 100,K
IF(K.EQ.'B')GO TO 75
IF(R2.EQ.0)R2=1
IF(R.EQ.0)R=1
DO 13 K=1,512
X=FUNC(K)
FUNC(K)=FUNC(K)*R+F2(K)*R2+C
13 F2(K)=X
GO TO 104
73 IF(MA.NE.'C')GO TO 44
DO 45 K=1,512
F2(K)=FUNC(K)
45 FUNC(K)=FUNC(K)+C
GO TO 104
44 IF(MA.NE.'I')GO TO 46
DO 47 K=1,512
F2(K)=FUNC(K)
47 FUNC(K)=C-FUNC(K)
GO TO 104
46 IF(MA.NE.'R')GO TO 75
48 DO 50 K=1,512
50 F2(K)=FUNC(513-K)
DO 51 K=1,512
X=FUNC(K)
FUNC(K)=F2(K)+C
51 F2(K)=X
GO TO 104
102 DO 103 K=1,512
X=FUNC(K)
FUNC(K)=FUNC(K)*F2(K)+C
103 F2(K)=X
104 A(1,2)=520
CALL NORM(FUNC)
C NORMALIZES THE FUNCTION
CALL DPY(FUNC,1)
TYPE 6
ACCEPT 100,K
IF(K.EQ.'M')GO TO 43
IF(K.NE.'B')RETURN
DO 14 K=1,512
14 FUNC(K)=F2(K)
15 CALL DPY(FUNC,1)
GO TO 43
1 FORMAT
1(' A(DD), M(ULT), R(ETRO), I(NVRT), OR C,N (=ADD CONSTANT N) ',$)
100 FORMAT(A1,F)
2 FORMAT(' 2ND FUNC? ',$)
3 FORMAT(A3)
10 FORMAT(' TYPE RATIO (E.G. 1,2) ',$)
39 FORMAT(10(A1,A3))
11 FORMAT(2F)
6 FORMAT(' F(INISH), OR M(ORE)? ',$)
60 FORMAT(' GO ON? ',$)
END
SUBROUTINE DPYF(N,F)
COMMON/S/H,AMP,CON,PH
COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
DIMENSION F(1)
NODPY=-1
IF(N.GT.0)GO TO 8
N=JX
NODPY=0
CC COLGATE 6/74--SEE MAIN AT 1201-18 IF(XA(N).EQ.'SEG')GO TO 5
8 IF(XA(N).NE.'SYNTH')GO TO 5
CALL ZERO(F)
K=1
1 AMP=AA(2,K,N)
H=AA(1,K,N)
PH=AA(3,K,N)
CON=AA(4,K,N)
CALL SYN(F)
K=K+1
IF(AA(1,K,N).NE.999)GO TO 1
CALL NORM(F)
GO TO 4
5 K=1
G=AA(2,1,N)
IF(G.EQ.520)GO TO 6
J=1
IF(G.LE.1)GO TO 22
Y=0
K=0
C FOR START BEYOND STEP 1 - ASSUMES A 0,1.
GO TO 2
22 Y=AA(1,1,N)
2 K=K+1
M=AA(2,K,N)*5.12+.5
IF(M.GT.512)GO TO 6
G=AA(1,K,N)
Z=G-Y
H=M-J+1
IF(H.LT.1)H=1
NN=0
DO 3 L=J,M
F(L)=(NN*Z)/H+Y
3 NN=NN+1
IF(M.EQ.512)GO TO 4
Y=G
J=M+1
GO TO 2
C FOR LONG FUNCS.
6 L=K+1
DO 7 M=1,512
7 F(M)=AA(M,L,N)
4 IF(NODPY)CALL DPY(F,-1)
C NODPY=0 IS FOR PLOTTER AND LPT
C NOW FUNCTION IS FULL AND DISPLAYED
RETURN
END
SUBROUTINE SYN(F)
COMMON/S/H,AMP,CON,PH
DIMENSION F(1)
DATA FAC/0.703125/,FACP/1.422222/
X=PH*FACP+1.0
C PHASE IS IN DEGREES (0 - 360)
2016 DO 17 L=1,512
XL=SIND(X*FAC)*AMP+CON
IF(CON.LT.100.0)GO TO 1
F(L)=(XL-100.)*F(L)
GO TO 2
1 F(L)=F(L)+XL
C NORMALIZES THE FUNCTION
2 X=X+H
17 IF(X.GT.512.)X=X-512.
RETURN
END
SUBROUTINE ZERO(F)
DIMENSION F(1)
DO 1 K=1,512
1 F(K)=0
RETURN
END
SUBROUTINE NORM(F)
DIMENSION F(1)
X=F(1)
C NORMALIZES THE FUNCTION
DO 19 K=2,512
XK=ABS(F(K))
19 IF(X.LT.XK)X=XK
DO 20 K=1,512
20 F(K)=F(K)/X
RETURN
END
SUBROUTINE SSS(VV,N1,A1)
DIMENSION V(50,4),A1(512),C(30,4),YP(30),J(30),NX(3),KA(14),K(9)
DIMENSION VV(50,4)
EQUIVALENCE(K1,K(1)),(K2,K(2)),(K3,K(3)),(K4,K(4)),(K5,K(5)),
1 (K6,K(6)),(K7,K(7)),(K8,K(8)),(K9,K(9))
DATA KA/1,2,2,1,1,2,1,1,0,2,1,-1,0,1/,DX/.00001/
IF(VV(1,2).EQ.0) VV(1,2)=1
DO 5 I=1,30
DO 5 L=1,2
5 V(I,L)=VV(I,L)
NX(1)=N1
698 NX(2)=NX(1)-1
DO 10 I=1,NX(1)
10 V(I,2)=(V(I,2)-1)/99.
DO 20 I=2,NX(2)
JX=I+1
JZ=I-1
YP(I)=(V(JX,1)-V(JZ,1))/(V(JX,2)-V(JZ,2))
20 IF((V(JX,1)-V(I,1))*(V(I,1)-V(JZ,1)).LE.0) YP(I)=0
DO 22 I=1,9
22 K(I)=KA(I)
KOUNT=0
21 KOUNT=KOUNT+1
V1=V(K2,1)-V(K1,1)
V2=V(K2,2)-V(K1,2)
802 IF((YP(K2)-V1/V2)*(V(K3,1)-V(K4,1)).GT.0) GO TO 30
24 Z=V(K2,K5)+(V(K1,K6)-V(K2,K6))*YP(K2)**K7
IF(YP(K2)**2.LT.DX.AND.V1**2.LT.DX) GO TO 36
IF(YP(K2)**2.LT.DX) GO TO 38
D1=V(K2,K5)-Z
806 D2=Z-V(K1,K5)
ZZ=(V(K1,K6)*D2+V(K2,K6)*D1)/(D1+D2)
808 YP(K1)=(ZZ*K9+V(K2,1)*K8-V(K1,1))/
1 (ZZ*K8+V(K2,2)*K9-V(K1,2))
GO TO 40
30 DO 32 I=5,9
32 K(I)=KA(I+5)
GO TO 24
36 YP(K1)=0
GO TO 40
38 YP(K1)=-100
IF(KOUNT.EQ.2) GO TO 39
IF(V(K2,1).GT.V(K1,1)) YP(K1)=100
GO TO 40
39 IF(V(K2,1).LT.V(K1,1)) YP(K1)=100
40 IF(KOUNT.EQ.2) GO TO 50
DO 42 I=1,2
K(I)=NX(I)
42 K(I+2)=K(I)
DO 44 I=5,9
44 K(I)=KA(I)
GO TO 21
50 NX(3)=NX(2)-1
N=1
52 N=N+1
IF(N.GT.NX(3)) GO TO 92
JX=N+1
V1=V(JX,1)-V(N,1)
V2=V(JX,2)-V(N,2)
Y1=YP(N)-YP(JX)
IF(Y1**2.LT.DX.AND.V1**2.GT.DX) GO TO 720
710 X=(V1-YP(JX)*V(JX,2)+YP(N)*V(N,2))/Y1
715 IF(X.GE.V(N,2).AND.X.LE.V(JX,2)) GO TO 52
IF(Y1**2.LT.DX.AND.V1**2.LT.DX) GO TO 52
720 DO 120 I=NX(1),JX,-1
JZ=I+1
V(JZ,2)=V(I,2)
V(JZ,1)=V(I,1)
120 YP(JZ)=YP(I)
YP(JX)=.5*V1/V2
IF(V1*(YP(N)-V1/V2).LE.0) YP(N+1)=4*YP(JX)
V(JX,2)=.5*(V(N+2,2)+V(N,2))
V(JX,1)=.5*(V(N+2,1)+V(N,1))
N=JX
DO 88 L=1,3
88 NX(L)=NX(L)+1
GO TO 52
92 DO 140 I=1,NX(2)
JX=I+1
W0=YP(I)
W1=YP(JX)
W2=V(JX,2)-V(I,2)
W3=V(JX,1)-V(I,1)
C(I,1)=(W2*(W0+W1)-2*W3)/(W0-W1)
C(I,2)=W2-C(I,1)
C(I,4)=W0*C(I,2)
140 C(I,3)=-C(I,4)+W3
730 DO 150 I=1,NX(1)
150 J(I)=511*V(I,2)+1
740 DO 160 I=1,NX(2)
L1=J(I)+1
IF(I.EQ.1) L1=1
ZZ=C(I,2)
XX=C(I,1)
L2=J(I+1)
750 DO 160 L=L1,L2
X=(FLOAT(L)-1.)/511.
IF(XX**2.LT.DX) GO TO 155
ZX=.5*SQRT(ZZ**2-4*XX*(V(I,2)-X))/XX
T1=-.5*ZZ/XX+ZX
T2=T1-2*ZX
IF(T2.GT.-DX.AND.T2.LT.(1+DX)) T1=T2
155 IF(XX**2.LT.DX) T1=-(V(I,2)-X)/ZZ
160 A1(L)=C(I,3)*T1**2+C(I,4)*T1+V(I,1)
770 END